#!/usr/bin/perl -w
# vim:tw=100 sw=2 expandtab ft=perl
#
#    Rollout
#    Copyright (C) 2007 David Parrish
#
#    This program is free software; you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation; either version 2 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program; if not, write to the Free Software
#    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#

use strict;
use Net::HTTP;
use Carp;
use Sys::Hostname;
use Data::Dumper;
use IO::File;
use IO::Select;
use Digest::MD5 qw( md5_hex );
use Getopt::Long;
use POSIX qw( setsid );
use File::Temp qw/ tempfile tempdir /;
use Fcntl ':flock';
use English;
use Socket;

use vars qw( $rollout_url $verbosity $safe_mode @skip_steps @force_dangerous
             %networks @only_steps $server_mode $server_allow $server_base
             $server_listen $rollout_comment $start_time );
$rollout_url = "http://rollout.domain";
$verbosity = 1;
$safe_mode = 0;
$server_mode = 0;
$server_base = undef;
$server_allow = "127.0.0.0/8";
$server_listen = "0.0.0.0:80";
my $hostname = hostname;
my @original_argv = @ARGV;

GetOptions(
  "verbose|v"       => sub { $verbosity++ },
  "quiet|q"         => sub { $verbosity = 0 },
  "safe_mode|s"     => \$safe_mode,
  "url|u=s"         => \$rollout_url,
  "skip_step|k=s"   => \@skip_steps,
  "hostname|h=s"    => \$hostname,
  "only|o=s"        => \@only_steps,
  "help|?"          => \&usage,
  "force|f=s"       => \@force_dangerous,
  "server"          => \$server_mode,
  "server_allow=s"  => \$server_allow,
  "server_base=s"   => \$server_base,
  "server_listen=s" => \$server_listen,
) or usage();

sub usage {
  print "Command line arguments are:\n";
  print " verbose|v      Increase verbosity\n";
  print " quiet|q        Don't print anything except fatal errors\n";
  print " safe_mode|s    Show what will be changed, but don't actually do anything\n";
  print " url|u          Set the base Rollout HTTP url\n";
  print " skip_step|k=s  Specify a step to be skipped, may be specified multiple times\n";
  print " hostname|h=s   Rollout configuration for a different host. If -f network is provided, ".
                         "the hostname will be changed\n";
  print " only|o=s       Only run a specific step (can be specified multiple times)\n";
  print " force|f=s      Force a dangerous step to be run\n";
  print " server         Enable server mode. Specify --server_allow and --server_base\n";
  print " server_allow   A comma-separated list of netmasks to allow access\n";
  print " server_base    The base of the directory tree served by rollout server\n";
  print " server_listen  The ip:port combo to listen on.\n";
  print "\n";
  print "Steps which are considered dangerous are always run in safe mode, unless the -f ".
        "parameter is specified with a step name as argument.\n";
  print "Any additional arguments will be combined to form the 'comment' which will be logged. ".
        "This should be used to describe the reason for running rollout, ".
        "i.e. a change tracking number or authorization\n";
  print "\n";
  exit;
}

# Global variables
$hostname =~ s/\..*//;
my(@all_steps, $steps, %steps_code, $current_step);
use vars qw( %m );
my $log = "";
$rollout_comment = join(" ", @ARGV) || "No comment specified";
$rollout_comment =~ s/(^['"]|['"]$)//g;
my $pid = $$;

# Logging wrappers {{{
sub l(@) {
  my($text, $indent) = @_;
  return unless $verbosity;
  $indent = 2 unless defined $indent;
  $indent = " " x $indent;
  my $newtext = $text;
  $newtext =~ s/^/$indent/mg;
  print "$newtext\n";
  $log .= "$text\n";
  return 0;
}

sub w(@) {
  my($text, $indent) = @_;
  return unless $text;

  $indent = 2 unless defined $indent;
  $indent = " " x $indent;
  my $newtext = $text;
  $newtext =~ s/^/${indent}WARNING: /mg;
  print "$newtext\n";
  $log .= "$text\n";

  return 0;
}

sub fatal(@) {
  print "------ FATAL ERROR ------\n";
  print "$_\n" foreach (@_);
  print "Current Step: $current_step\n" if $current_step;
  exit 1 if $current_step;
}

sub d($) { return v(Dumper(@_)) }
sub v(@) { l(@_) if $verbosity > 1; return 1 }

# }}}
sub named_params(\@$) { #{{{
  my($params, $defaults) = @_;
  return undef unless $params && @$params;
  return $params->[0] if ref $params->[0] eq 'HASH' && @$params == 1;
  my $return = {};

  if (@$params % 2 != 0 || $params->[0] !~ /^-/) {
    # Positional parameters
    my @order;
    for (my $i = 0; $i < @$defaults; $i += 2) {
      my($key, $value) = ($defaults->[$i], $defaults->[$i + 1]);
      push @order, $key;
    }
    return $params unless @order;

    foreach (@order) {
      last unless @$params;
      $_ = "-$_" unless /^-/;
      $return->{$_} = shift @$params;
    }

    return $return;
  }

  # Named parameters
  for (my $i = 0; $i < @$defaults; $i += 2) {
    my($key, $value) = ($defaults->[$i], $defaults->[$i + 1]);
    $return->{$key} = $value if defined $value;
  }

  for (my $i = 0; $i < @$params; $i += 2) {
    my($key, $value) = ($params->[$i], $params->[$i + 1]);
    $return->{$key} = $value;
  }
  return $return;
}
#}}}
# HTTP functions {{{

sub http_file(@) {
  my $p = named_params @_, [ -url => undef, -dest => undef ];
  my $file = $p->{-url};
  return undef unless $file;

  my $url = $file =~ /^http:\/\// ? $file : "$rollout_url/$file";
  my($host, $port, $path) = $url =~ /^(?:http:\/\/)?([^\/:]+)(?::(\d+))?(\/?.*)/;
  my $s = Net::HTTP->new(Host => $host, PeerPort => $port || 80) || fatal $@;

  $s->write_request(GET => $path, 'User-Agent' => "Rollout/1.0");
  my($code, $mess, %h) = $s->read_response_headers;

  w "GET $url returned $code" and return undef unless $code =~ /^2../;

  my $fh;
  if ($p->{-dest}) {
    v "Writing to $p->{-dest}.$$";
    if (!($fh = new IO::File ">$p->{-dest}.$$")) {
      w "Can't write to $p->{-dest}.$$: $!";
      return undef;
    }
  }

  my $res = "";
  while (1) {
    my $buf;
    my $n = $s->read_entity_body($buf, 1024);
    fatal "Read failed: $!" unless defined $n;
    last unless $n;
    if ($fh) {
      if (syswrite($fh, $buf, $n) < $n) {
        fatal "Error writing to $p->{-dest}.$$: $!";
        $fh->close;
        unlink("$p->{-dest}.$$");
      }
      $res += $n;
    } else {
      $res .= $buf;
    }
  }

  if ($p->{-dest}) {
    $fh->close;
    if (-f $p->{-dest} && -s $p->{-dest} && !-s "$p->{-dest}.$$") {
      w "Not overwriting existing file with nothing";
      unlink "$p->{-dest}.$$";
      return undef;
    }
    w "Unable to rename $p->{-dest}.$$ to $p->{-dest}" unless
      rename("$p->{-dest}.$$", $p->{-dest});
  }

  return $res;
}

sub http_index(@) {
  my $p = named_params @_, [ -url => undef ];
  my $base = $p->{-url};
  return undef unless $base;

  $base .= "/" unless $base =~ /\/$/;

  my $html = http_file -url => $base;
  return () unless $html;

  my @files;
  while ($html =~ /^(?:<tr><td valign="top">)?<img src="[^"]+" alt="[^"]+">(?:<\/td><td>| )?<a href="([^"]+)">(.+?)<\/a>(?:<\/td>| )/mg) {
    my($filename, $name) = ($1, $2);
    next if !$filename || $name =~ /Parent Directory/i || $filename =~ /\?/;
    push @files, $filename;
  }
  return @files;
}

# Install a whole directory's files
sub dir_install {
  my $p = named_params @_, [ -src => undef, -dest => undef, -cmd => undef, -flags => {},
                             -dir_flags => {}, -mode => undef, -uid => undef, -owner => undef,
                             -gid => undef, -group => undef, -dir_mode => undef ];

  $p->{-dir_flags}{-mode} ||= $p->{-dir_mode} if $p->{-dir_mode};
  $p->{-flags}{-mode} ||= $p->{-mode} if $p->{-mode};
  foreach (qw( uid gid owner group )) {
    $p->{-dir_flags}{-$_} ||= $p->{-$_} if $p->{-$_};
    $p->{-flags}{-$_} ||= $p->{-$_} if $p->{-$_};
  }
  dir_check(-dir => $p->{-dest}, %{$p->{-dir_flags}});

  return w "No source specified" unless $p->{-src};
  return w "No destination specified" unless $p->{-dest};

  $p->{-src} =~ s/^rollout:/$rollout_url/;
  my $restart = 0;
  if ($p->{-src} =~ /^http:\/\//) {
    my @files = http_index $p->{-src};
    return w "Couldn't retrieve index $p->{-src}" unless @files;
    foreach my $filename (@files) {
      if ($filename =~ /\/$/) {
        # It's a directory
        $filename =~ s/\/$//;
        if (!$p->{-flags}->{no_recurse}) {
          v "Recursing into $filename ($p->{-src}/$filename => $p->{-dest}/$filename)";
          dir_install(-src => "$p->{-src}/$filename",
                      -dest => "$p->{-dest}/$filename",
                      -flags => $p->{-flags},
                      -dir_flags => $p->{-dir_flags}) && $restart++;
        }
      } else {
        v "Installing file $p->{-src}/$filename to $p->{-dest}/$filename";
        my $file = http_file -url => "$p->{-src}/$filename";
        if (defined($file)) {
          text_install(-file => "$p->{-dest}/$filename", -text => $file, -flags => $p->{-flags})
            && $restart++;
          set_attr(-file => "$p->{-dest}/$filename", %{$p->{-flags}}) && $restart++;
        } else {
          w "Error retrieving $p->{-src}/$filename";
        }
      }
    }
  }

  command($p->{-cmd}) if $restart && $p->{-cmd};
  return $restart ? 1 : 0;
}

#}}}
# i_* functions {{{

sub i_iterate {
  my($key, $func, $m, $donecache) = @_;
  $m ||= $hostname;
  $donecache ||= {};
  my $found = 0;
  return 0 unless $m{$m};
  return 0 if $donecache->{$m}++;
  if ($m{$m}->{$key}) {
    my $x = $func->($m, $m{$m}->{$key});
    return $found unless (defined $x);
    $found += $x;
  }
  $found += i_iterate($key, $func, $_, $donecache) foreach (keys %{$m{$m}->{ISA} || {}});
  return $found;
}

sub i_has {
  my($class, $m) = @_;
  # Return only the first element, which is likely to be the most specific
  my $ret = undef;
  i_iterate($class, sub { $ret = $_[1]; return undef });
  return $ret;
}

sub _i_in {
  my($grep) = @_;
  return sub { return scalar(grep { $_ eq $grep } @{$_[1]}) }
}

sub i_immutable_file {
  return i_iterate("immutable_file", _i_in($_[0]), $_[1]);
}

sub i_unsafe_file {
  return i_iterate("unsafe_file", _i_in($_[0]), $_[1]);
}

sub i_unsafe_dir {
  return i_iterate("unsafe_dir", _i_in($_[0]), $_[1]);
}

sub i_should {
  my($item, $m) = @_;
  my $step_name = ($current_step =~ /^\d+-(.*)$/)[0];
  my $should_not = 0;
  i_iterate("skip_steps", sub {
    $should_not += 1 if grep { $_ eq "$current_step:$item" } @{$_[1]};
    $should_not += 1 if grep { $_ eq "$step_name:$item" } @{$_[1]};
  });
  return !$should_not;
}

sub i_isa {
  my($class, $m) = @_;

  $m ||= $hostname;
  return 0 unless $m{$m} && $m{$m}->{ISA};
  return $m{$m}->{ISA}{$class} if $m{$m}->{ISA}{$class};

  foreach (keys %{$m{$m}->{ISA}}) {
    my $ret = i_isa($class, $_);
    return $ret if $ret;
  }
  return 0;
}

sub i_isa_fetchall {
  my($class, $m) = @_;
  my @list;
  i_iterate($class, sub { push @list, $_[1] }, $m);
  return @list;
}

sub add_isa {
  my($class, $m) = @_;

  $m ||= $hostname;
  return 0 unless $m{$m};
  $m{$m}->{ISA} ||= {};
  $m{$m}->{ISA}{$class} ||= 1;
}

sub i_isa_classes {
  my($class) = @_;

  $class ||= $hostname;

  my %list;
  return () unless $m{$class};

  foreach (keys %{$m{$class}->{ISA} || {}}) {
    if ($m{$class}) {
      $list{$_} = 1 foreach i_isa_classes($_);
    }
    $list{$_} = 1;
  }

  return keys %list;
}

sub i_ip {
  my($host) = @_;
  foreach (i_isa_fetchall("interfaces", $host)) {
    while (my($name, $int) = each(%$_)) {
      next unless $int->{primary};
      next unless $int->{gateway};
      next unless $int->{ip};
      return $int->{ip};
    }
  }
  return undef;
}

# }}}
# Configuration lookup functions {{{
sub c {
  my($key, $default, $donecache) = @_;
  return wantarray ? () : undef unless $key;
  $donecache ||= {};
  my(@key) = split(/\//, $key);
  my $base = shift @key;
  return wantarray ? () : $default if $donecache->{$base}++;

  my @ret;
  my $x = $m{$base};
  for (my $i = 0; $i <= $#key; $i++) {
    last unless ref $x eq 'HASH';
    $x = $x->{$key[$i]};
    last unless defined($x);
    push @ret, $x if $i == $#key;
  }
  if ($m{$base}->{ISA}) {
    foreach (keys %{$m{$base}->{ISA}}) {
      push @ret, c(join("/", $_, @key), $default, $donecache);
    }
  }
  return wantarray ? @ret : ($ret[0] || $default);
}

sub uniq {
  my(@input) = @_;
  my @output;
  my %done;
  foreach (@input) {
    next if $done{$_}++;
    push @output, $_;
  }
  return @output;
}

sub merge_hashes {
  my($x, $y) = @_;
  return [uniq(@$x, @$y)] if ref $x eq 'ARRAY';
  return [uniq($x, $y)] unless ref $x;
  $x->{$_} = defined $x->{$_} ? merge_hashes($x->{$_}, $y->{$_}) : $y->{$_} foreach keys %$y;
  return $x;
}

sub flatten_hash {
  my(@input) = @_;
  my $output = {};
  $output = merge_hashes($output, $_) foreach @input;
  return %$output;
}

sub flatten_list {
  my(@input) = @_;
  my @output = ();
  foreach (@input) {
    push @output, $_ and next unless ref $_ eq 'ARRAY';
    push @output, @$_;
  }
  return @output;
}

sub flatten_list_all {
  my(@input) = @_;
  my @output = ();
  foreach (@input) {
    push @output, $_ and next unless ref $_ eq 'ARRAY';
    push @output, flatten_all(@$_);
  }
  return @output;
}
# }}}
# PriorityQueue {{{
package PriorityQueue;

sub new {
  my $self = { queue => [], prios => {} };
  return bless $self, shift();
}

sub pop {
  my($self) = @_;
  return undef unless @{$self->{queue}};
  delete($self->{prios}->{$self->{queue}->[0]});
  return shift(@{$self->{queue}});
}

sub insert {
  my($self, $payload, $priority, $lower, $upper) = @_;
  $lower ||= 0;
  $upper = scalar(@{$self->{queue}}) - 1 unless defined($upper);
  $self->{prios}->{$payload} = $priority;
  return push(@{$self->{queue}}, $payload) unless @{$self->{queue}};
  return push(@{$self->{queue}}, $payload) if $priority >= $self->{prios}->{$self->{queue}->[-1]};
  return unshift(@{$self->{queue}}, $payload) if $priority < $self->{prios}->{$self->{queue}->[0]};
  return splice(@{$self->{queue}}, 1, 0, $payload) if @{$self->{queue}} == 2;
  my $midpoint;
  while ($upper >= $lower) {
    $midpoint = ($upper + $lower) >> 1;
    if ($priority < $self->{prios}->{$self->{queue}->[$midpoint]}) {
      $upper = $midpoint - 1;
      next;
    }
    $lower = $midpoint + 1;
  }

  splice(@{$self->{queue}}, $lower, 0, $payload);
}

sub _find_payload_pos {
  my($self, $payload) = @_;
  my $priority = $self->{prios}->{$payload};
  return undef unless defined($priority);
  my $lower = 0;
  my $upper = @{$self->{queue}} - 1;
  my $midpoint;
  while ($upper >= $lower) {
    $midpoint = ($upper + $lower) >> 1;
    if ($priority < $self->{prios}->{$self->{queue}->[$midpoint]}) {
      $upper = $midpoint - 1;
      next;
    }
    $lower = $midpoint + 1;
  }
  while ($lower-- >= 0) {
    return $lower if ($self->{queue}->[$lower] eq $payload);
  }
}

sub delete {
  my($self, $payload) = @_;
  my $pos = $self->_find_payload_pos($payload);
  return undef unless defined($pos);
  delete($self->{prios}->{$payload});
  splice(@{$self->{queue}}, $pos, 1);
  return $pos;
}

sub update {
  my($self, $payload, $new_prio) = @_;
  my $old_prio = $self->{prios}->{$payload};
  my $old_pos = $self->delete($payload);
  my($upper, $lower);
  if ($new_prio - $old_prio > 0) {
    $upper = @{$self->{queue}};
    $lower = $old_pos;
  } else {
    $upper = $old_pos;
    $lower = 0;
  }
  $self->insert($payload, $new_prio, $lower, $upper);
}

package main;
# }}}

sub queue_step {
  my($step) = @_;

  my($x) = grep /((?:\d+-)?$step)/, @all_steps;
  fatal "Can't find step $step to queue" unless $x;

  v "Queueing step $x";
  $steps->insert($x, 0);
}

sub run_step {
  my($filename) = @_;
  $current_step = $filename;
  l $filename, 0;
  $steps_code{$filename} ||= http_file -url => "steps/$filename";
  w "Can't retrieve step $filename" and next unless $steps_code{$filename};

  eval $steps_code{$filename};
  exit unless $pid == $$;
  if ($@) {
    l "------ FATAL ERROR ------";
    l "$_" foreach ($@);
    my($step, $last_step);
    while (($step = $steps->pop())) {
      $last_step = $step;
    }
    $steps->insert($last_step, 0) if $last_step;
  }
}

# Adds a command to be run just before completion
sub queue_command {
  my($cmd, $prio) = @_;
  $prio = 998 unless defined $prio;
  v "Queueing command $cmd at $prio";
  $steps->insert(sub { command($cmd) }, $prio);
}

# Adds a sub to be run just before completion
sub queue_code {
  my($sub, $prio) = @_;
  $prio = 998 unless defined $prio;
  v "Queueing code $sub at $prio";
  $steps->insert($sub, $prio);
}

# File & Directory modification #{{{

sub slurp_file($) {
  my $file = shift;
  local $/;

  my $fh = IO::File->new($file) or return w "Can't open file $file: $!";
  return <$fh>;
}

sub file_append {
  my $p = named_params @_, [ -file => undef, -add => undef, -match => undef, -cmd => undef,
                             -create => 0 ];
  local $_;

  if (defined $p->{-match} and $p->{-add} !~ /$p->{-match}/) {
    w "Skipping append of $p->{-file}: '$p->{-match}' does NOT match '$p->{-add}'";
    return 0;
  }

  # Only compare first line for multiline $p->{-add}
  my($firstline) = $p->{-add};
  $firstline =~ s/\n.*$/\n/s;

  unless (-f $p->{-file}) {
    return w "$p->{-file} does not exist!" if $safe_mode;
    IO::File->new(">$p->{-file}")->close if $p->{-create}; # Touch file.
  }

  my $t = '';
  my $added = 0;
  my $fh = IO::File->new($p->{-file}) or return w "$p->{-file} unable to be opened: $!";

  while (<$fh>) {
    if ($p->{-match} and /$p->{-match}/) {
      if (/^\Q$firstline\E[\r\n]*/) {
        $fh->close;
        return 0;
      }
      if (!$added) {
        $t .= $p->{-add};
        $t .= "\n" unless $p->{-add} =~ /\n$/;
        $added = 1;
      }
    } else {
      $t .= $_;
    }
  }

  $fh->close;

  if (!$added) {
    $t .= $p->{-add};
    $t .= "\n" unless $p->{-add} =~ /\n$/;
  }

  l "Modified $p->{-file} by appending $p->{-add}";
  safe_write(-file => $p->{-file}, -text => $t);

  if (defined $p->{-cmd} && !$safe_mode) {
    l "Running $p->{-cmd} to finish install of $p->{-file}";
    command($p->{-cmd});
  }

  return 1;
}

sub file_modify {
  my $p = named_params @_, [ -file => undef, -cmd => undef, -modify => [] ];
  my @expr = ref $p->{-modify} eq 'ARRAY' ? @{$p->{-modify}} : [ $p->{-modify} ];
  local $_;

  (-f $p->{-file}) or return l "$p->{-file} does not exist!";

  my $fh = IO::File->new($p->{-file}) or return l "$p->{-file} unable to be opened: $!";

  my($changes, $f, %c);
  while (<$fh>) {
    my $original = $_;

    foreach my $e (@expr) {
      eval $e;
    }

    $changes++ unless $original eq $_;
    $f .= $_;
  }

  $fh->close;
  return unless $changes;

  l "Modified $p->{-file} with ". join(", ", @expr);
  safe_write(-file => $p->{-file}, -text => $f);

  if (defined $p->{-cmd} && !$safe_mode) {
    l "Running $p->{-cmd} to finish install of $p->{-file}";
    command($p->{-cmd});
  }

  return 1;
}

sub safe_write {
  my $p = named_params @_, [ -file => undef, -text => undef, -mode => undef, -comment => undef ];

  my($dir, $file) = $p->{-file} =~ /(?:(.*)\/)?(.*)/;
  $p->{-mode} ||= (stat($p->{-file}))[2];
  $p->{-comment} ||= "Rollout";

  return 1 if $safe_mode;

  $dir ||= ".";

  if (!-x "/usr/bin/ci" || i_unsafe_file($file) || i_unsafe_dir($dir)) {
    # RCS is not installed, don't do version control
    safe_write_file(-file => $p->{-file}, -text => $p->{-text});
    chmod $p->{-mode}, $p->{-file} if $p->{-mode};
    return 1;
  }

  my $rcs = "$dir/RCS/$file,v";

  if (-f "$dir/$file") {
    mkdir("$dir/RCS", 0700) if not -d "$dir/RCS" and -w $dir;
    system("ci", "-q", "-m\"Untracked Changes\"", "-t-\"Initial Checkin\"", "-l", "$dir/$file");
    system("rcs", "-q", "-ko", "$dir/$file");
  }

  safe_write_file(-file => $p->{-file}, -text => $p->{-text});

  if (-f "$dir/$file") {
    mkdir("$dir/RCS", 0700) if not -d "$dir/RCS" and -w $dir;
    system("ci", "-q", "-t-\"Initial checkin\"", "-m\"$p->{-comment}\"", "-l", "$dir/$file");
    system("rcs", "-q", "-ko", "$dir/$file");
  }

  chmod $p->{-mode}, $p->{-file} if $p->{-mode};

  return 1;
}

sub safe_write_file {
  my $p = named_params @_, [ -file => undef, -text => undef ];
  my $file = $p->{-file};

  return 1 if $safe_mode;

  my $fh = IO::File->new(">$file.$$") or fatal "Unable to open $file: $!";

  # If the argument is a filehandle, use that.
  if (ref $p->{-file} and defined fileno $p->{-file}) {
    local ($_, $!);
    my $in = $p->{-file};
    $fh->print($_) while <$in>;
    fatal "Unable to write $file: $!" if $!;
  } else {
    $fh->print($p->{-text}) or fatal "Unable to write to $file: $!";
  }

  $fh->close or fatal "Unable to write to $file: $!";

  rename("$file.$$", $file) or fatal "Unable to rename $file.$$: $!";
}

sub set_attr {
  my $p = named_params @_, [ -file => undef, -mode => undef, -uid => undef, -gid => undef,
                             -owner => undef, -group => undef];
  $p->{-file} ||= $p->{-dir};
  return w "No filename given to set_attr" unless $p->{-file};

  my($mode, $uid, $gid);

  for ($p->{-mode}) {
    last unless defined;
    if (/^\d+$/) {
      $mode = $_ & 07777;
    } elsif (/^([r-][w-][stx-]){3}$/) {
      $mode = 0;
      my $shift = 2;
      for (/^(...)(...)(...)$/) {
        $mode |= 1 <<  (9 + $shift)       if s/[st]/x/;
        $mode |= 1 << (($shift * 3) + 2)  if /r/;
        $mode |= 1 << (($shift * 3) + 1)  if /w/;
        $mode |= 1 <<  ($shift * 3)       if /x/;
        $shift--;
      }
    } else {
      fatal "Invalid mode for $p->{-file}: $_";
    }
  }

  for ($p->{-owner} || $p->{-uid}) {
    last unless defined;
    if (/^\d+$/) {
      $uid = $_;
    } else {
      unless (defined ($uid = getpwnam $_)) {
        w "Can't find user $_";
        $uid = -1;
      }
    }
  }

  for ($p->{-group} || $p->{-gid}) {
    last unless defined;
    if (/^\d+$/) {
      $gid = $_;
    } else {
      unless (defined ($gid = getgrnam $_)) {
        w "Can't find group $_";
        $gid = -1;
      }
    }
  }

  return 0 unless defined $mode or defined $uid or defined $gid;

  my @stat = stat $p->{-file};
  unless (@stat) {
    # May not exist yet
    w "Can't stat $p->{-file}: $!" unless $safe_mode;
    return 0;
  }

  my $changed = 0;
  if (defined $mode and ($stat[2] & 07777) != $mode) {
    l sprintf("Changing mode of %s to %o", $p->{-file}, $mode);
    $changed++;
    unless ($safe_mode) {
      chmod $mode, $p->{-file} or
        w sprintf("chmod %o %s failed: $!", $mode, $p->{-file});
    }
  }

  if (defined $uid and $stat[4] != $uid) {
    l "Changing owner of $p->{-file} to $uid";
    $changed++;
  } else {
    $uid = -1;
  }

  if (defined $gid and $stat[5] != $gid) {
    l "Changing group of $p->{-file} to $gid";
    $changed++;
  } else {
    $gid = -1;
  }

  if ($uid != -1 or $gid != -1 && !$safe_mode) {
    chown $uid, $gid, $p->{-file} or
      w sprintf("chown %d:%d %s failed: $!", $uid, $gid, $p->{-file});
  }

  return $changed;
}

sub text_install {
  my $p = named_params @_, [ -file => undef, -text => undef, -cmd => undef, -flags => {} ];
  my $changed = 1;

  # Create containing directory if it doesn't exist

  (my $path = $p->{-file}) =~ s,/[^/]+$,,;
  command("mkdir -p $path") if $path and $path ne $p->{-file} and ! -d $path;

  $p->{-flags}->{srcfn} ||= "text";

  # If they are the same, don't bother ..
  #   and they can't have the same md5 if they're different sizes ..

  if (-f $p->{-file} and -s _ == length($p->{-text})) {
    my $src_md5 = Digest::MD5->new->add($p->{-text})->hexdigest;
    my $dst_md5 = Digest::MD5->new->add(slurp_file $p->{-file})->hexdigest;
    $changed = 0 if $src_md5 eq $dst_md5;
  }

  if ($changed) {
    my $ref = ref $p->{-flags}->{srcfn};
    if ($ref eq "ARRAY") {
      fatal "Multiple sources for \"$p->{-file}\":\n" . join("\n", @{$p->{-flags}->{srcfn}}) . "\n";
    } else {
      l "Installing $p->{-file} from $p->{-flags}->{srcfn}";
    }
    if ($safe_mode) {
      v $p->{-text};
    } else {
      safe_write(-file => $p->{-file}, -text => $p->{-text})
      or return w "Unable to install $p->{-file}: $!";
    }
  }

  $changed += set_attr($p);
  if ($changed and defined $p->{-cmd} and !$safe_mode) {
    l "Running $p->{-cmd} to finish install of $p->{-file}";
    command($p->{-cmd});
  }

  $changed;
}

sub file_install {
  my $p = named_params @_, [ -file => undef, -src => undef, -cmd => undef, -flags => {},
                             -modify => [] ];
  my @expr = ref $p->{-modify} eq 'ARRAY' ? @{$p->{-modify}} : [ $p->{-modify} ];
  my $srctext = '';

  $p->{-src} =~ s/^rollout:/$rollout_url/;
  if ($p->{-src} =~ /^http:\/\//) {
    local $_;
    $_ = http_file -url => $p->{-src};
    return w "Couldn't retrieve $p->{-src}" unless $_;
    foreach my $e (@expr) {
      eval $e;
    }
    $srctext = $_;
  } elsif (-s $p->{-src}) {
    if (@expr) {
      my $fh = IO::File->new($p->{-src}) or fatal "can't open $p->{-src}: $!";
      local $_;
      while (<$fh>) {
        foreach my $e (@expr) {
          eval $e;
        }
        $srctext .= $_;
      }

      $fh->close;
    } else {
      $srctext = slurp_file $p->{-src};
    }
  }

  $p->{-flags}{srcfn} ||= $p->{-src};
  $p->{-text} = $srctext;
  return text_install($p);
}

sub dir_check {
  my $p = named_params @_, [ -dir => undef, -mode => undef, -uid => undef, -gid => undef ];
  my $flags;
  my $changed;

  unless (-e $p->{-dir}) {
    # make parent if required
    (my $parent = $p->{-dir}) =~ s/\/[^\/]+$//;
    if ($parent && !-e $parent) {
      my $x = $p;
      $x->{-dir} = $parent;
      dir_check($p);
    }
    $p->{-mode} ||= 0755;

    l sprintf("Creating directory %s with mode 0%03o", $p->{-dir}, $p->{-mode});
    return 1 if $safe_mode;

    my $mask = umask 0;
    mkdir $p->{-dir}, $p->{-mode} or fatal "Can't create directory $p->{-dir}: $!";
    umask $mask;

    $changed++;
  } else {
    fatal "$p->{-dir} is not a directory" unless -d _;
  }

  return (set_attr($p)) || $changed;
}

sub symlink_check {
  my $p = named_params @_, [ -src => undef, -dest => undef ];
  if (-l $p->{-dest}) {
    return 0 if (readlink $p->{-dest}) eq $p->{-src};
    l "Changing target of symlink $p->{-dest} to $p->{-src}";
    unless ($safe_mode) {
      unlink $p->{-dest} or fatal "Can't unlink $p->{-dest}: $!";
      symlink $p->{-src}, $p->{-dest} or fatal "Can't symlink $p->{-src} to $p->{-dest}: $!";
    }

    return 1
  }

  w "$p->{-dest} is not a symlink" or return 0 if -e _;
  unless ($safe_mode) {
    l "Creating symlink from $p->{-src} to $p->{-dest}";
    symlink $p->{-src}, $p->{-dest} or fatal "Can't symlink $p->{-src} to $p->{-dest}: $!";
  }

  return 1
}

#}}}
# file_[un]comment {{{
# file, comment directive, command to run, list of regexps matching lines to replace

sub file_comment_spec {
  my $p = named_params @_, [ -file => undef, -pat => '#', -cmd => undef, -match => [] ];
  my @regex = ref $p->{-match} eq 'ARRAY' ? @{$p->{-match}} : [ $p->{-match} ];
  local $_;

  return w "$p->{-file} does not exist!" unless -f $p->{-file};

  my $fh = new IO::File $p->{-file}
    or return w "$p->{-file} unable to be opened: $!";

  my($changes, $f, %c);
  while (<$fh>) {
    if (! /^$p->{-pat}/) {
      foreach my $r (@regex) {
        if (/$r/) {
          s/^/$p->{-pat}/;
          $changes++;
          $c{$r}++;
          last;
        }
      }
    }

    $f .= $_;
  }

  $fh->close;
  return unless $changes;

  safe_write(-file => $p->{-file}, -text => $f);

  l "$p->{-file} changed: commented out ". join(', ', keys %c);

  if (defined $p->{-cmd}) {
    v "Running $p->{-cmd} to finish install of $p->{-file}";
    command($p->{-cmd});
  }

  return $changes;
}

sub file_comment {
  my $p = named_params @_, [ -file => undef, -cmd => undef, -match => [], -pat => '#' ];
  return file_comment_spec($p->{-file}, $p->{-pat}, $p->{-cmd}, $p->{-match});
}

sub file_uncomment_spec {
  my $p = named_params @_, [ -file => undef, -pat => '#', -cmd => undef, -match => [] ];
  my @regex = ref $p->{-match} eq 'ARRAY' ? @{$p->{-match}} : [ $p->{-match} ];

  return w "$p->{-file} does not exist!" unless -f $p->{-file};

  my $fh = new IO::File $p->{-file}
    or return w "$p->{-file} unable to be opened: $!";

  my($changes, $f, %c);
  while (<$fh>) {
    foreach my $r (@regex) {
      if (/$p->{-pat}.*$r/) {
        s/^$p->{-pat}+//;
        $changes++;
        $c{$r}++;
        last;
      }
    }
    $f .= $_;
  }

  $fh->close;
  return unless $changes;

  safe_write(-file => $p->{-file}, -text => $f);

  l "$p->{-file} changed: uncommented ". join(', ', keys %c);

  if (defined $p->{-cmd}) {
    v "Running $p->{-cmd} to finish install of $p->{-file}";
    command($p->{-cmd});
  }

  return $changes;
}

sub file_uncomment {
  my $p = named_params @_, [ -file => undef, -cmd => undef, -match => [], -pat => '#' ];
  return file_uncomment_spec($p->{-file}, $p->{-pat}, $p->{-cmd}, $p->{-match});
}
#}}}
# Package Installation {{{

$ENV{DEBIAN_FRONTEND} = 'noninteractive';
sub apt {
  my(@packages) = @_;
  v "Installing ". join(" ", @packages);
  command("apt-get -qq update") unless $m{$hostname}->{_done_apt_update}++;
  if (-x "/usr/bin/dpkg") {
    return command("apt-get", "-qy", "-oStopOnError=false", "-oDPkg::Options={\"--force-confold\"}",
                   "--force-yes", "--allow-unauthenticated", "install", @packages);
  } else {
    return command("apt-get", "-qy", "--force-yes", "install", @packages);
  }
}

sub package_status {
  my($package) = @_;

  if (-f "/etc/debian_version") {
    return package_status_dpkg($package);
  } elsif (-f "/etc/redhat-release") {
    return package_status_rpm($package);
  }
}

sub package_status_dpkg {
  my($package) = @_;
  my $status = $m{$hostname}->{_pkg_status};
  if (!$status) {
    $status = {};
    my $text = slurp_file("/var/lib/dpkg/status");
    foreach (split(/\n\n/, $text)) {
      if (/^Package: (.*)$/m) {
        my $pkg = $1;
        if (/^Status:.* installed.*$/m) {
          $status->{$pkg} = 1;
        } else {
          $status->{$pkg} = 0;
        }
      }
    }
    $m{$hostname}->{_pkg_status} = $status;
  }
  return $status->{$package} || 0;
}

sub package_status_rpm {
  my($package) = @_;
  my $status = $m{$hostname}->{_pkg_status} || {};
  $m{$hostname}->{_pkg_status} = $status;

  if (!defined $status->{$package}) {
    my $return_pkg_val = `rpm -q $package --queryformat "%{NAME}.%{ARCH}\n"`;
    $status->{$package} = $?;
    if (($status->{$package} == 0) && ($return_pkg_val =~ m/^\Q$package/)) {
      $status->{$package} = 0;
    } else {
      $status->{$package} = 1;
    }
  }

  return $status->{$package};
}

sub package_check {
  my(@packages) = @_;

  my $available_packages = $m{$hostname}->{_available_packages};
  $m{$hostname}->{_done_packages} ||= {};

  my @add;
  foreach my $package (@packages) {
    next if $m{$hostname}->{_done_packages}{$package}++;
    next if package_status($package);
    next if $package =~ /^(http:\/\/|rollout:)/;
    push @add, $package;
  }

  my $changes = 0;
  if (@add) {
    if (!$available_packages) {
      v "Updating packages list";
      command("apt-get -q update") unless $m{$hostname}->{_done_apt_update}++;
    }

    l "Installing packages ". join(" ", @add);
    apt(@add) && $changes++;
  }

  foreach my $url (@packages) {
    $url =~ s/^rollout:/$rollout_url/;
    next unless $url =~ /^(http:\/\/[^\/]+).*\/([a-z0-9\._\-]+\.(?:deb|rpm))/i;

    my($package, $filename) = ($2, $2);
    $package =~ s/[_-]\d+.*//;

    next if $m{$hostname}->{_done_packages}{$package}++;
    next if package_status($package);

    l "Installing $package from $url";

    if ($filename =~ /\.rpm$/) {
      command("rpm", "-U", $url) && $changes++;
    } else {
      my $data = http_file -url => $url;
      if (!$data) {
        w "Couldn't retrieve $url";
        next;
      }
      if ((my $fh = new IO::File ">/tmp/$filename")) {
        print $fh $data;
        close($fh);

        if ($filename =~ /\.deb$/) {
          command("dpkg", "-i", "/tmp/$filename") && $changes++;
        } else {
          w "Unknown package type for $url";
        }

        unlink("/tmp/$filename");
      } else {
        w "Couldn't write to /tmp/$filename: $!";
        next;
      }
    }
  }

  return $changes ? 1 : 0;
}

sub package_uncheck {
  my(@packages) = @_;

  $m{$hostname}->{_done_packages} ||= {};

  my @remove;
  foreach my $package (@packages) {
    next if $m{$hostname}->{_done_packages}{$package}++;
    next unless package_status($package);
    push @remove, $package;
  }

  if (@remove) {
    l "Removing packages ". join(" ", @remove);
    command("apt-get", "-qq", "-y", "remove", @remove);
  }
}
#}}}

# An optional hashref as the last argument can set custom messages:
#   failure - print this if command fails.
#   success - print this if command succeeds and produces output. (quiet otherwise)
#   intro   - print this before running the command (and suppress "success")
sub command {
  my $flags = {};
  $flags = pop @_ if ref $_[-1] eq 'HASH';

  my $command = join " ", @_;
  my $printed = 0;
  $flags->{intro} ||= '';
  $flags->{failure} ||= "FAILED: '$command' failed.";
  $flags->{success} ||= "Finished running '$command'.";
  $flags->{timeout} = undef unless $flags->{timeout};

  v "CMD: $command";
  $printed++ if $verbosity > 1;

  return if $safe_mode;

  print $flags->{intro} if $flags->{intro};

  my $cmd = IO::File->new;
  my $child = $cmd->open('-|');
  unless ($child) {
    fatal "Can't fork in command: $!" unless defined $child;

    $SIG{PIPE} = 'IGNORE';

    # detach from controlling tty
    setsid;
    open STDIN, '</dev/null';
    open(STDERR, '>&STDOUT');

    $|=1;
    exec @_;
    die "Can't execute ". join (" ", @_). ": $!";
    exit;
  }

  local $_;
  my $timed_out = 1;
  my $out = length $flags->{intro};
  my $nl = $flags->{intro} =~ /\n$/;

  my $s = IO::Select->new($cmd);
  while ($s->can_read($flags->{timeout})) {
    unless ($cmd->sysread($_, 1024)) {
      $timed_out = 0;
      last;
    }

    my $t;
    $t = "  CMD: " if $nl or !$out;
    s/\n(?=.)/\n  CMD: /g;
    $t .= $_;
    if (!$printed) {
      l "CMD: $command";
      $printed++;
    }
    print $t;
    $log .= $t;

    $out += length;
    $nl = /\n$/;
  }

  if ($timed_out) {
    print "[timeout]\n";
    kill 15, $child;
  } else {
    print "\n" if $out and !$nl;
  }

  $cmd->close;
  if ($? >> 8) {
    l $flags->{failure}. "  Exit code: " . ($? >> 8);
  } elsif ($?) {
    l $flags->{failure}. "  Signal: " . ($? & 0x7f);
  } elsif ($out and not exists $flags->{intro}) {
    l $flags->{success};
  }

  # emulate a return of system()
  return $?;
}

sub cvs_checkout {
  my $p = named_params @_, [ -dest => undef, -module => undef, -rev => undef, -repo => undef,
                             -cmd => undef ];
  return w "Not enough parameters specified to cvs_checkout"
    unless $p->{-dest} && $p->{-module} && $p->{repo};

  v "CVS checkout $p->{-dest}:". ($p->{-rev} || "notag");
  if (-d $p->{-dest} && !-d "$p->{-dest}/CVS") {
    w "$p->{-dest} exists but is not a CVS checkout";
    return 0;
  }
  if (-d $p->{-dest}) {
    chdir $p->{-dest};
    command("cvs", "-q", "update", "-dPA", ($p->{-rev} ? ("-r", $p->{-rev}) : ()));
    command($p->{-cmd}) if $p->{-cmd};
    return 1;
  } else {
    my($base, $newdir) = $p->{-dest} =~ /(.+)\/(.+)/;
    return w "Can't parse dir $p->{-dest}" unless $base && $newdir;
    dir_check($base);
    return w "Checkout to $p->{-dest} failed" unless -d $base;
    chdir $base;
    command("cvs", "-d", $p->{-repo}, "-q", "checkout", "-P",
            ($p->{-rev} ? ("-r", $p->{-rev}) : ()), "-d", $newdir, $p->{-module});
    chdir $p->{-module} && command($p->{-cmd}) if $p->{-cmd};
    return 1;
  }
  return 0;
}

sub svn_checkout {
  my $p = named_params @_, [ -dest => undef, -url => undef, -rev => undef, -cmd => undef ];
  return w "Not enough parameters specified to svn_checkout" unless $p->{-dest} && $p->{-url};

  v "svn checkout $p->{-dest}:". ($p->{-rev} || "HEAD");
  if (-d $p->{-dest} && !-d "$p->{-dest}/.svn") {
    w "$p->{-dest} exists but is not a svn checkout";
    return 0;
  }
  if (-d $p->{-dest}) {
    chdir $p->{-dest};
    command("svn", "update", ($p->{-rev} ? ("-r", $p->{-rev}) : ()));
    command($p->{-cmd}) if $p->{-cmd};
    return 1;
  } else {
    my($base, $newdir) = $p->{-dest} =~ /(.+)\/(.+)/;
    return w "Can't parse dir $p->{-dest}" unless $base && $newdir;
    dir_check($base);
    return w "Checkout to $p->{-dest} failed" unless -d $base;
    chdir $base;
    command("svn", "checkout", ($p->{-rev} ? ("-r", $p->{-rev}) : ()), $p->{-url}, $newdir);
    chdir $newdir && command($p->{-cmd}) if $p->{-cmd};
    return 1;
  }
  return 0;
}

sub expand_network($) {
  my($network) = @_;
  return () unless $network;
  $network =~ s/(^\[|\]$)//g;
  return ($network) if $network =~ /^\d+\.\d+\.\d+\.\d+/;
  return @{$networks{$network} || []};
}

if ($server_mode) {
  die "You must specify --server_base and --server_allow\n" unless $server_base && $server_allow;
  require RolloutServer;
  import RolloutServer;

  my $server = new RolloutServer($server_listen, $server_allow, $server_base);
  $server->run();
  exit 0;
}


if (open(LOCKFILE, ">/var/run/rollout.lock")) {
  die "There is already an instance of rollout running"
    unless flock(LOCKFILE, LOCK_EX | LOCK_NB);
}

$start_time = time;
@all_steps = http_index "steps";
fatal "Can't find any steps to execute" unless @all_steps;
unshift @only_steps, "setup", "os-detection" if @only_steps;
push @only_steps, "complete" if @only_steps;
v "Only running steps: " . join(", ", @only_steps) if @only_steps;

$steps = new PriorityQueue;
foreach (@all_steps) {
  next unless /^(\d+)-(.*)/;
  $steps->insert($_, int($1));
}

# Run the first step (001-setup)
run_step($steps->pop());

# Allow steps to be reordered and duplicated
my @reorder_steps = flatten_list(c("$hostname/rollout/reorder_steps"));
for (my $i = 0; $i < @reorder_steps; $i += 2) {
  $steps->update($reorder_steps[$i], $reorder_steps[$i + 1]);
}
my @copy_steps = flatten_list(c("$hostname/rollout/copy_steps"));
for (my $i = 0; $i < @copy_steps; $i += 2) {
  $steps->insert($copy_steps[$i], $copy_steps[$i + 1]);
}

while ((my $step = $steps->pop())) {
  next if grep { $step =~ /^\d*-?$_$/ } @skip_steps;
  next if @only_steps && !grep { $step =~ /^\d*-?$_$/ } @only_steps;
  next unless i_should('*'); # skip_steps => [ 'foobar:*' ]

  if (ref $step eq 'CODE') {
    $step->();
  } else {
    run_step($step);
  }
}

close(LOCKFILE);
unlink("/var/run/rollout.lock");

